home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / internet / vbipsmtp / uucode.bas < prev    next >
Encoding:
BASIC Source File  |  1996-02-17  |  7.4 KB  |  267 lines
  1. Attribute VB_Name = "uucode"
  2. Option Explicit
  3. '---------------------------------------------------
  4. 'UUCODE.BAS
  5. 'Copyright 1996 by Carl Franklin
  6. 'Unauthorized reproduction in any medium of this
  7. 'source code is strictly prohibited without written
  8. 'permission from the author and John Wiley & Sons.
  9. '---------------------------------------------------
  10.  
  11. Function Decode(szData As String) As String
  12.  
  13.     On Error GoTo HepMe
  14.     
  15.     Dim szOut   As String
  16.     Dim nChar   As Integer
  17.     Dim I       As Integer
  18.     
  19.     For I = 1 To Len(szData) Step 4
  20.         szOut = szOut & Chr((Asc(Mid(szData, I, 1)) - 32) * 4 + (Asc(Mid(szData, I + 1, 1)) - 32) \ 16)
  21.         szOut = szOut & Chr((Asc(Mid(szData, I + 1, 1)) Mod 16) * 16 + (Asc(Mid(szData, I + 2, 1)) - 32) \ 4)
  22.         szOut = szOut & Chr((Asc(Mid(szData, I + 2, 1)) Mod 4) * 64 + Asc(Mid(szData, I + 3, 1)) - 32)
  23.     Next I
  24.     
  25.     Decode = szOut
  26.     
  27.     Exit Function
  28.     
  29. HepMe:
  30.  
  31.     Stop
  32.     
  33. End Function
  34.  
  35. Function Encode(szData As String) As String
  36.  
  37.     Dim szOut   As String
  38.     Dim nChar   As Integer
  39.     Dim I       As Integer
  40.     
  41.     '   pad to 3 byte multiple
  42.     If Len(szData) Mod 3 <> 0 Then szData = szData & Space(3 - Len(szData) Mod 3)
  43.     
  44.     For I = 1 To Len(szData) Step 3
  45.         szOut = szOut & Chr(Asc(Mid(szData, I, 1)) \ 4 + 32)
  46.         szOut = szOut & Chr((Asc(Mid(szData, I, 1)) Mod 4) * 16 + Asc(Mid(szData, I + 1, 1)) \ 16 + 32)
  47.         szOut = szOut & Chr((Asc(Mid(szData, I + 1, 1)) Mod 16) * 4 + Asc(Mid(szData, I + 2, 1)) \ 64 + 32)
  48.         szOut = szOut & Chr(Asc(Mid(szData, I + 2, 1)) Mod 64 + 32)
  49.     Next I
  50.     
  51.     Encode = szOut
  52.     
  53. End Function
  54.  
  55. Function nMakeMsgWithFiles(szMsg As String, szFiles() As String, szOutputFile As String) As Integer
  56. '********************************************************************
  57. '   nMakeMsgWithFiles (by Carl Franklin)
  58. '
  59. '   This function creates an SMTP mail message
  60. '   with embedded uuencoded binary files. No header
  61. '   is created.
  62. '
  63. '   Parameters: szMsg           Message text
  64. '               szFiles()       List of filenames to be embedded
  65. '               szOutputFile    Name of the file to be created
  66. '
  67. '   Returns:    The function returns an error if
  68. '               one occurs.
  69. '********************************************************************
  70.     
  71.     Dim nMsgFile    As Integer
  72.     Dim nIndex      As Integer
  73.     Dim nErrCode    As Integer
  74.     Dim nUUEFile    As Integer
  75.     Dim szLine      As String
  76.     
  77.     On Error GoTo nMakeMsgWithFiles_Error
  78.  
  79.     nMsgFile = FreeFile
  80.     
  81.     '-- Write the message portion to the file
  82.     Open szOutputFile For Output As nMsgFile
  83.         Print #nMsgFile, szMsg
  84.         Print #nMsgFile, ""
  85.     Close nMsgFile
  86.     
  87.     '-- Append all the encoded files to the master file.
  88.     For nIndex = 1 To UBound(szFiles())
  89.         nErrCode = UUEncode(szFiles(nIndex), szOutputFile, True)
  90.         If nErrCode Then
  91.             nMakeMsgWithFiles = Err
  92.             Exit Function
  93.         End If
  94.     Next
  95.     
  96.     '-- Add the trailing period
  97.     nMsgFile = FreeFile
  98.     Open szOutputFile For Append As nMsgFile
  99.     Print #nMsgFile, "."
  100.     Close nMsgFile
  101.     
  102.     Exit Function
  103.     
  104. nMakeMsgWithFiles_Error:
  105.     
  106.     nMakeMsgWithFiles = Err
  107.     On Error Resume Next
  108.     Close nMsgFile
  109.     Exit Function
  110.  
  111. End Function
  112.  
  113. Function UUDecode(szFileIn As String, szFileOut As String) As Integer
  114.  
  115.     Dim nFileIn     As Integer
  116.     Dim nFileOut    As Integer
  117.     Dim szData      As String
  118.     Dim szOut       As String
  119.     Dim lBytesIn    As Long
  120.     Dim lFullLines  As Long
  121.     
  122.     On Error GoTo ERR_UUDecode
  123.     
  124.     '   open the ascii input file
  125.     nFileIn = FreeFile
  126.     Open szFileIn For Input As nFileIn
  127.     
  128.     '   find the header in the input file
  129.     While LCase(Left(Trim(szData), 6)) <> "begin "
  130.         Line Input #nFileIn, szData
  131.         Wend
  132.     
  133.     '   open the binary output file
  134.     nFileOut = FreeFile
  135.     
  136.     '   if an output file wasn't given, take the name from the input file
  137.     If szFileOut = "" Then
  138.         szData = Trim(szData)
  139.         szData = Trim(Mid(szData, InStr(szData, " ")))
  140.         szFileOut = Trim(Mid(szData, InStr(szData, " ")))
  141.         End If
  142.         
  143.     Open szFileOut For Binary As nFileOut
  144.     
  145.     Do While Not EOF(nFileIn)
  146.         
  147.         '   get a 45 bytes chunk, encode it and put it in the output file
  148.         Line Input #nFileIn, szData
  149.         
  150.         If Trim$(LCase$(szData)) = "end" Then
  151.             Exit Do
  152.         ElseIf Trim$(szData) <> "" Then
  153.             '   decode the input line and put it into the output file
  154.             szOut = Left(Decode(Mid(szData, 2, Len(szData) - 1)), Asc(Left(szData, 1)) - 32)
  155.             Put #nFileOut, , szOut
  156.         End If
  157.         
  158.     Loop
  159.         
  160.     '   close the files
  161.     Close nFileIn
  162.     Close nFileOut
  163.     
  164.     '   if we got this far, then it must have worked!
  165.     '       return of 0 means there were no errors
  166.     UUDecode = 0
  167.     
  168.     Exit Function
  169.  
  170. ERR_UUDecode:
  171.     '   argghhh!, something went wrong, return the error code
  172.     UUDecode = Err
  173.     
  174.     Close nFileIn
  175.     Close nFileOut
  176.     
  177.     Exit Function
  178.     
  179. End Function
  180.  
  181. Function UUEncode(szFileIn As String, szFileOut As String, nAppend As Integer) As Integer
  182.  
  183.     Dim nFileIn     As Integer
  184.     Dim nFileOut    As Integer
  185.     Dim nIndex      As Integer
  186.     Dim szData      As String
  187.     Dim lBytesIn    As Long
  188.     Dim lFullLines  As Long
  189.     
  190.     On Error GoTo ERR_UUEncode
  191.     
  192.     '   open the binary input file
  193.     nFileIn = FreeFile
  194.     Open szFileIn For Binary As nFileIn
  195.     lBytesIn = LOF(nFileIn)
  196.     
  197.     '   open the ascii output file
  198.     nFileOut = FreeFile
  199.     If nAppend Then
  200.         Open szFileOut For Append As nFileOut
  201.     Else
  202.         Open szFileOut For Output As nFileOut
  203.     End If
  204.     
  205.     '-- Return just the filename portion of the outfile
  206.     For nIndex = Len(szFileOut) - 1 To 1 Step -1
  207.         If Mid$(szFileOut, nIndex, 1) = "\" Then
  208.             szFileOut = Mid$(szFileOut, nIndex + 1)
  209.             Exit For
  210.         End If
  211.     Next
  212.     
  213.     '   put the header in the output file
  214.     Print #nFileOut, "begin 644 " & szFileIn
  215.     
  216.     '   determine how many full lines we get, 45 bytes gets
  217.     '   expanded to 60 bytes
  218.     lFullLines = lBytesIn \ 45
  219.     szData = Space(45)
  220.     
  221.     
  222.     While lFullLines > 0
  223.         
  224.         '   get a 45 bytes chunk, encode it and put it in the output file
  225.         Get nFileIn, , szData
  226.         
  227.         
  228.         Print #nFileOut, "M" & Encode(szData)
  229.         
  230.         '   another one "bytes" the dust
  231.         lFullLines = lFullLines - 1
  232.         
  233.         Wend
  234.         
  235.     '   determine the leftover portion
  236.     szData = Space(lBytesIn Mod 45)
  237.     
  238.     '   get the partial chunk of bytes that are left
  239.     Get nFileIn, , szData
  240.     
  241.     '   put them in the output file
  242.     Print #nFileOut, Chr(Len(szData) + 32) & Encode(szData)
  243.     
  244.     '   add on the file trailer
  245.     Print #nFileOut, "end"
  246.     
  247.     '   close the files
  248.     Close nFileIn
  249.     Close nFileOut
  250.     
  251.     '   if we got this far, then it must have worked!
  252.     '       return of 0 means there were no errors
  253.     UUEncode = 0
  254.     
  255.     Exit Function
  256.  
  257. ERR_UUEncode:
  258.     '   argghhh!, something went wrong, return the error code
  259.     UUEncode = Err
  260.     
  261.     Close nFileIn
  262.     Close nFileOut
  263.     
  264.     Exit Function
  265.  
  266. End Function
  267.